home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Modules / cfqs.em < prev    next >
Lisp/Scheme  |  1992-10-06  |  2KB  |  84 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;                                                                           ;;
  3. ;;  EuLisp Module                     Copyright (C) University of Bath 1991  ;;
  4. ;;                                                                           ;;
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6.  
  7. (defmodule cfqs
  8.  
  9.   (standard futures) ()
  10.  
  11.   (defun car1 (x) (if (futurep x)
  12.               (car (futureeval x))
  13.             (car x)))
  14.  
  15.   (defun cdr1 (x) (if (futurep x)
  16.               (cdr (futureeval x))
  17.             (cdr x)))
  18.  
  19.   (defun null1 (x) (if (futurep x)
  20.                (null (futureeval x))
  21.              (null x)))
  22.  
  23.   (defun defuturize (x) (if (futurep x) (futureeval x) x))
  24.  
  25.   (defun greaterp1 (x y)
  26.     (progn
  27.       (if (futurep x)
  28.       (setq x (futureeval x))
  29.     nil)
  30.       (if (futurep y)
  31.       (setq y (futureeval y))
  32.     nil)
  33.       (not (< x y))))
  34.  
  35.   (defun qsort (l) (qs l nil))
  36.  
  37.   (defun qs (l rest)
  38.     (if (null1 l)
  39.     (defuturize rest)
  40.       (let ((parts (partition (car1 l) (cdr1 l))))
  41. ;;    (bindings 'parts) % show bindings for parts
  42.     (qs (left-part parts)
  43.         (future (cons (car1 l) (qs (right-part parts) rest)))))))
  44.  
  45.   (defun partition (elt lst)
  46.     (progn
  47. ;;      (print "Env at start of partition")
  48. ;;      (showenv thisenv)
  49. ;;      (reclaim)
  50.       (if (null1 lst)
  51.       (bundle-parts nil nil)
  52.     (let ((cdrparts (future (partition elt (cdr1 lst)))))
  53.       (if (greaterp1 elt (car1 lst))
  54.           (bundle-parts (cons (car1 lst)
  55.                   (future (left-part cdrparts)))
  56.                 (future (right-part cdrparts)))
  57.         (bundle-parts (future (left-part cdrparts))
  58.               (cons (car1 lst)
  59.                 (future (right-part cdrparts))))))))
  60.     )
  61.  
  62.   (defun bundle-parts (x y) (cons x y))
  63.  
  64.   (defun left-part (p) (car1 p))
  65.  
  66.   (defun right-part (p) (cdr1 p))
  67.  
  68.   (defun wop () (print (qsort '(5 1 2 4 3))) (wop))
  69.  
  70.   (defun make-random-list (n)
  71.     (labels
  72.       ((aux (n l)
  73.      (if (= n 0) l
  74.        (aux (- n 1) (cons (c-rand) l)))))
  75.       (aux n ())))
  76.  
  77.   (setq l1 (make-random-list 20))
  78.  
  79.   (setq l2 (make-random-list 40))
  80.   
  81.   (export qsort make-random-list)
  82. )
  83.  
  84.